R Graphics
Insert image in R rmarkdown

Sample Image
ggplot
Add annotation with special symbols
- Add text on a ggplot graph with a special symbol
- With newline and variables
library(ggplot2)
library(data.table)
dt <- data.table(var_x = 1:10, var_y= (1:10) ^ 2)
value_rho = as.character(0.77)
text <- expression("Spearman's" ~ rho ~ "= 0.77")
text <- bquote(atop("Top Line", "Spearman's" ~ rho ~ "=" ~ .(value_rho)))
ggplot(data = dt, mapping = aes(x = var_x, y = var_y)) +
geom_point(size = 2, alpha = (1:10) / 10) +
annotate("text", x = 2, y = 80, label = text)Pass Column Names to ggplot inside a function
- sym() function turns text into a symbol, like as.name() or as.symbol
- !! function is to unquote a symbol
- Use color from a column in a data frame, use scal_color_identity to deactivate legend by colour
library(data.table)
library(ggplot2)
dt <- data.table(A=1:10
, B=1:10
, C=rep(1:5, each=2)
, sex=factor(rep(c("M", "F"), each=5))
)
clrs <- c("#FF0000", "#00FF00")
dt[["varcolor"]] <- clrs[as.numeric(dt$sex)]
plt <- function(x, y, group){
x <- sym(x)
y <- sym(y)
ggplot(dt, aes(x=!!x, y=!!y)) +
geom_point() +
facet_wrap(as.formula(paste0("~", group)), nrow = 1)
}
plt("A", "B", "sex")ggplot(dt, aes(x=C, group=sex, colour=varcolor, fill=varcolor)) +
geom_bar() + scale_colour_identity() + scale_fill_identity()Stacked Bar Charts by Count
Stacked Bar Charts by Percentage
library(data.table)
dt <- data.table(
day = sample(1:14, size = 1400, replace = TRUE)
, state = sample(c("Good", "Bad"), size = 1400, replace = TRUE)
, group = sample(c("I", "II", "III"), size = 1400, replace = TRUE)
)
p <- ggplot(dt, aes(x = day, fill = state)) +
geom_bar(position = "fill") +
facet_wrap( ~ group, ncol = 3)
pViolin Plot
library(data.table)
library(ggplot2)
set.seed(123456)
dt <- data.table(
group = rep(c("A", "B", "C"), each = 300)
, sex = sample(c("F", "M"), size = 900, replace = TRUE)
, value = rnorm(900)
)
ggplot(dt, aes(y = value, x = group)) +
geom_violin(trim=TRUE) +
geom_boxplot(width=.1) +
xlab("Group") + ylab("Value")font_tick_size <- 10
font_axis_size_x <- 20
font_axis_size <- 15
ggplot(dt, aes(y = value, x=sex)) +
geom_violin(trim=TRUE) +
geom_boxplot(width=0.1) +
facet_grid(cols=vars(group)) +
## scale_y_continuous(trans="log", breaks=brks) +
labs(y = "Value", x = "Sex") +
## scale_y_continuous(breaks = seq(0,4,1), limits = c(-0.2,4), expand = c(0, 0)) +
## scale_x_continuous(breaks = seq(0,200,50), limits = c(-10,220), expand = c(0, 0)) +
theme(axis.text.x = element_text(size = font_tick_size)
, axis.text.y = element_text(size = font_tick_size)
, axis.title.x = element_text(size = font_axis_size_x)
, axis.title.y = element_text(size = font_axis_size)
## , plot.margin = unit(plot_margin, "cm")
, axis.line = element_line(colour = "grey")
## , axis.ticks = element_blank()
## , panel.grid.major = element_line(colour = "#DDDDDD", size = 0.1)
## , panel.grid.minor = element_blank()
, panel.background = element_blank()
, strip.background =element_rect(fill="#FFFFFF")
, strip.text.x = element_text(size = font_axis_size)
)## p <- ggplot(dt, aes(y = relative, x=sex)) +
## geom_violin(trim=TRUE) +
## facet_grid(rows=vars(area), cols=vars(age_group))
## p <- ggplot(dt, aes(y = relative, x=sex)) +
## geom_violin(trim=TRUE) +
## scale_y_continuous(trans="log", breaks=c(0.01, 0.02, 0.04, 0.08, 0.16, 0.32, 0.64, 1.28, 2.56)) +
## facet_grid(rows=vars(area), cols=vars(age_group)) +
## labs(y="log transformed relative")Forest Plot
dt <- data.table(
name=factor(LETTERS[1:8], levels=LETTERS[1:8], ordered=TRUE)
, coef_value=1:8
, coef_value_lower=(1:8) - 0.5
, coef_value_upper=(1:8) + 0.5
)
dt <- dt[, name_label := factor(paste0(name, " ", "CI"))]
dt <- dt[, num_rep := 22 - nchar(round(coef_value, 4)) ]
p <- ggplot(dt
, aes(y = name_label
, x = coef_value
, xmin = coef_value_lower
, xmax = coef_value_upper
)) +
geom_vline(xintercept=1, color='grey', linetype='dashed',size=0.7) +
geom_errorbarh(height=0.2,color="#333333",size=0.8) +
geom_point(color = "#666666", size=2, shape=15) +
scale_x_continuous(limits=c(0,9)
, breaks=c(0,1,2,5, 9)
, name='Odds Ratio') +
## p <- p + scale_y_discrete(labels = "Y AXIS", sec.axis = dup.axis())
ylab("") +
theme_bw() +
theme(axis.ticks = element_blank()
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
) +
coord_cartesian(xlim=c(0, 9))
pForest Plot Log Scale
png(file="forestplot_irf.png", width = 2400, height = 1200, res = 300)
p <- ggplot(dt
, aes(y = name_label
, x = coef_value
, xmin = coef_value_lower
, xmax = coef_value_upper
))
p <- p + geom_vline(xintercept=1, color='grey', linetype='dashed',size=0.7)
p <- p + geom_errorbarh(height=0.2,color="#333333",size=0.8)
p <- p + geom_point(color = "#666666",size=1,shape=15)
p <- p + scale_x_continuous(limits=c(0.1,4), breaks=c(0.1, 0.2, 0.5,1,2,3, 4), name='Adjusted Odds Ratio (IPR)')
## p <- p + scale_y_discrete(labels = "Y AXIS", sec.axis = dup.axis())
p <- p + ylab("")
p <- p + theme_bw()
p <- p + theme(axis.ticks = element_blank()
, panel.grid.major = element_blank(),
panel.grid.minor = element_blank()
)
p <- p + coord_cartesian(xlim=c(0, 4)) + coord_trans(x="log")
p
dev.off()
include_graphics("forestplot_irf.png")Cell Plot
- Plot discrete daily progression states
library(ggplot2)
dt <- data.table(
id=1:10
, day=rep(1:28, each=10)
, state=sample(c("A", "B", "C", "D", "E", NA), 28 * 10, replace = TRUE)
)
dt <- dt[, state := factor(state, levels=c("A", "B", "C", "D", "E"), ordered = TRUE)]
clrs <- c("#2EAEE6"
## , "#2EE6CA"
## , "#2EE677"
, "#37E62E"
## , "#8AE62E"
, "#DCE62E"
, "#E69C2E"
, "#E6492E"
## , "#aaaaaa"
)
ggplot(dt, aes(x=day, y=id)) +
geom_tile(aes(fill=state, height=(1)), size=1) +
scale_y_discrete() +
scale_fill_manual(values = clrs)linecolor <- "#999999"
ggplot(dt, aes(y=id,x=day)) +
geom_point(aes(fill=state), colour="transparent", shape=22, size=4) +
scale_fill_manual(values = clrs)+
geom_line(aes(group = id), colour=linecolor, alpha=0.5) +
scale_x_continuous(breaks=c(7, 14, 21, 28)) +
scale_y_continuous(breaks=c(1, 3, 5, 7, 9)) +
labs(title = "Title. \n Discrete Time Plot", x="Day", y="ID") +
geom_vline(xintercept=c(7, 14), colour=linecolor,linetype="dashed") +
geom_vline(xintercept=21,colour=linecolor,linetype="dashed") +
theme(panel.background = element_rect(fill = "transparent")
, plot.background = element_rect(fill = "transparent", color = NA)
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
, legend.background = element_rect(fill = "transparent")
, legend.box.background = element_rect(fill = "transparent")
, legend.position = 'top'
, plot.margin=unit(c(1,2,1,2),"cm")
) +
coord_fixed(ratio = 3 / 2
, xlim = c(0.5, 28.5)
, ylim = c(0.5, 10.5)
, expand = FALSE) +
guides(fill = guide_legend(nrow = 1))Progression Bar Plot
rm(list=ls())
library(ggplot2)
library(data.table)
dt <- data.table(
id=rep(1:100, each=28)
, day=rep(1:28, 100)
, state=sample(c("A", "B", "C", "D", "E"), 28 * 100, replace = TRUE)
, treatment=rep(c("Case", "Control"), each=28 * 100 / 2)
)
dt <- dt[, state := factor(state, levels=c("A", "B", "C", "D", "E"), ordered = TRUE)]
clrs <- c("#2EAEE6"
## , "#2EE6CA"
## , "#2EE677"
, "#37E62E"
## , "#8AE62E"
, "#DCE62E"
, "#E69C2E"
, "#E6492E"
## , "#aaaaaa"
)
ggplot(dt, aes(x = factor(day), fill = state)) + geom_bar(position = "fill") +
facet_wrap(~treatment) + scale_fill_manual(values = clrs) +
xlab("Day State by Treatment") +
ylab("Proportions")ggplot(dt, aes(x=day, fill = state)) + geom_bar() +
facet_wrap(~treatment) + scale_fill_manual(values = clrs) +
labs(x="Day State by Treatment"
, y="Count"
, title="Progression by Treatment"
) +
scale_x_continuous(breaks=c(7, 14, 21, 28)) +
scale_y_continuous(breaks=c(10, 20, 30, 40, 50)) +
theme(panel.background = element_rect(fill = "transparent")
, plot.background = element_rect(fill = "transparent", color = NA)
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
, legend.background = element_rect(fill = "transparent")
, legend.box.background = element_rect(fill = "transparent")
, legend.position = 'top'
, plot.margin=unit(c(1,2,1,2),"cm")
) +
coord_fixed(ratio = 3 / 2
## , xlim = c(0.5, 28.5)
## , ylim = c(0.5, 10.5)
, expand = FALSE) +
guides(fill = guide_legend(nrow = 1))ggplot(dt, aes(x = factor(treatment), fill = state)) + geom_bar() +
facet_wrap(~factor(day), nrow=1) + scale_fill_manual(values = clrs) +
labs(x="Day State by Treatment"
, y="Count"
, title="Progression by Day"
) +
## scale_x_continuous(breaks=c(7, 14, 21, 28)) +
## scale_y_continuous(breaks=c(10, 20, 30, 40, 50)) +
theme(panel.background = element_rect(fill = "transparent")
, plot.background = element_rect(fill = "transparent", color = NA)
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
, legend.background = element_rect(fill = "transparent")
, legend.box.background = element_rect(fill = "transparent")
, legend.position = 'top'
, plot.margin=unit(c(1,2,1,2),"cm")
) +
## coord_fixed(ratio = 3 / 2
## , xlim = c(0.5, 28.5)
## , ylim = c(0.5, 10.5)
## , expand = FALSE) +
guides(fill = guide_legend(nrow = 1))Accumulative Distribution
ROC Curve
Simulate Data
library(data.table)
set.seed(123456)
n <- 1000
dt <- data.table(x = runif(n))
p0 <- 0.2
or <- 2
dt <- dt[, odds0 := p0 / (1 - p0)
][, log_odds := log(odds0) + x * log(or)
][, p := exp(log_odds) / (1 + exp(log_odds))]
hist(dt$p)vsample <- function(p){
sample(c(1, 0), size = 1, replace = TRUE, prob = c(p, 1 - p))
}
vsample <- Vectorize(vsample)
dt <- dt[, outcome := vsample(p)]
m <- glm(outcome ~ x, data = dt, family = binomial)
library(sjPlot)
tab_model(m)| outcome | |||
|---|---|---|---|
| Predictors | Odds Ratios | CI | p |
| (Intercept) | 0.23 | 0.17 – 0.31 | <0.001 |
| x | 1.99 | 1.20 – 3.30 | 0.008 |
| Observations | 1000 | ||
| R2 Tjur | 0.007 | ||
ggplot
pred <- predict(m, newdata = dt, type = "response")
library(pROC)
r <- roc(dt$outcome, pred, ci = TRUE, direction = "<")
dr <- data.table(
tpr = r$sensitivities
, fpr = 1 - r$specificities
)
dr <- dr[order(fpr, tpr)]
ggplot(dr, aes(x = fpr, y = tpr)) +
geom_segment(x = 0, y = 0, xend = 1, yend = 1, size = 0.5, color = "#999999", linetype = "longdash") +
geom_step(size = 1.5, color = "#333333", direction = "hv") +
xlab("FPR") + ylab("TPR") +
theme_bw() +
theme(axis.ticks.x = element_blank()
, axis.ticks.y = element_blank()
, axis.text.x = element_blank()
, axis.text.y = element_blank()
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
)Color
Hue Saturation Luminance (HSL)
- fig.width=7 inch
- fig.height=14 inch
- dpi=300
library(ggplot2)
dt <- expand.grid(seq(0, 340, 20), seq(0, 100, 10), seq(0, 100, 10))
dt <- as.data.table(dt)
colnames(dt) <- c("Hue", "Saturation", "Luminance")
## dt <- dt[, clr := hcl(Hue, Chroma, Luminance)]
dt <- dt[, clr := hsv(Hue / 360, Saturation / 100, Luminance / 100)]
ggplot(dt, aes(x=Saturation, y=Luminance, colour=clr)) +
geom_point(size=3) +
scale_color_identity() +
scale_x_continuous(breaks=seq(0, 100, 10)) +
scale_y_continuous(breaks=seq(0, 100, 10)) +
facet_wrap( ~ Hue, nrow=6)plotly
Radar Chart
dt <- readRDS(file="df.RDS")
rl <- dt[, .(m_mmdhp=median(sqrt(mmdhp_score_imp), na.rm = TRUE)
, m_js=median(edmcq_js_score_imp, na.rm = TRUE)
, ms_clt=median(edmcq_js_score_imp, na.rm = TRUE)
, ms_ldr=median(edmcq_ldr_score_imp, na.rm = TRUE)
, m_eol=median(edmcq_eol_score_imp, na.rm = TRUE)
)
, by = list(gender_q3.factor)
][order(gender_q3.factor)]
rl$m_mmdhp2 <- rl$m_mmdhp
dms <- c("MMD-HP", "Job Strain"
, "Safety Culture"
, "Leadership Culture"
, "End of Life"
, "MMD-HP"
)
opc <- 0.5
fig <- plot_ly(
type = 'scatterpolar',
fill = 'toself'
)
fig <- fig %>%
add_trace(
r = t(rl[1, 2:7, drop = TRUE])
, theta = dms
, name = rl$gender_q3.factor[1]
, opacity = opc
)
fig <- fig %>%
add_trace(
r = t(rl[2, 2:7, drop = TRUE])
, theta = dms
, name = rl$gender_q3.factor[2]
, opacity = opc
)
fig <- fig %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0, 4)
)
)
)
figOverlay Histogram
library(plotly)
p1 <- dt[mg_tp0.factor == "Yes"]$pred
p0 <- dt[mg_tp0.factor == "No"]$pred
plot_ly(alpha = 0.5, xbins = list(start = 0, end = 1, size = 0.02)) %>%
add_histogram(x = ~ p1
, name = "Magnesium"
, inherit = TRUE
## , xbins = seq(0, 1, 0.05)
) %>%
add_histogram(x = ~ p0
, name = "No"
, inherit = TRUE
## , xbins = seq(0, 1, 0.05)
) %>%
layout(barmode = "overlay"
, xaxis = list(title = paste0("Predicted Probabilities of Being Treated with Magnesium (AUC = ",format(r$auc,digits = 3), ")"),
zeroline = FALSE),
yaxis = list(title = "Count",
zeroline = FALSE))Animation
gifski
library(gifski)
png("frame%03d.png")
par(ask = FALSE)
for(i in 1:10)
plot((1:10) ^ (sqrt(i)), main = i)
dev.off()png 2
png_files <- sprintf("frame%03d.png", 1:10)
gif_file <- tempfile(fileext = ".gif")
gifski(png_files, gif_file)[1] “/tmp/RtmpHxpVxL/file45158ca81ac.gif”
# Example borrowed from gganimate
library(gapminder)
library(ggplot2)
makeplot <- function(){
datalist <- split(gapminder, gapminder$year)
lapply(datalist, function(data){
p <- ggplot(data, aes(gdpPercap, lifeExp, size = pop, color = continent)) +
scale_size("population", limits = range(gapminder$pop)) + geom_point() + ylim(20, 90) +
scale_x_log10(limits = range(gapminder$gdpPercap)) + ggtitle(data$year) + theme_classic()
print(p)
})
}
# High Definition images:
gif_file <- save_gif(makeplot(), width = 800, height = 450, res = 92)
## utils::browseURL(gif_file)
knitr::include_graphics(gif_file)gganimate
library(ggplot2)
library(gganimate)
ggplot(mtcars, aes(factor(cyl), mpg)) +
geom_boxplot() +
# Here comes the gganimate code
transition_states(
gear,
transition_length = 2,
state_length = 1
) +
enter_fade() +
exit_shrink() +
ease_aes('sine-in-out')library(gapminder)
ggplot(gapminder, aes(gdpPercap, lifeExp, size = pop, colour = country)) +
geom_point(alpha = 0.7, show.legend = FALSE) +
scale_colour_manual(values = country_colors) +
scale_size(range = c(2, 12)) +
scale_x_log10() +
facet_wrap(~continent) +
# Here comes the gganimate specific bits
labs(title = 'Year: {frame_time}', x = 'GDP per capita', y = 'life expectancy') +
transition_time(year) +
ease_aes('linear')R sessionInfo
R version 4.2.0 (2022-04-22) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.3 LTS
Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C
attached base packages: [1] stats graphics grDevices utils datasets methods base
other attached packages: [1] gapminder_0.3.0 gifski_1.6.6-1 pROC_1.18.0
[4] sjPlot_2.8.10 Wu_0.0.0.9000 flexdashboard_0.5.2 [7] lme4_1.1-29 Matrix_1.4-0 mgcv_1.8-38
[10] nlme_3.1-152 png_0.1-7 scales_1.2.0
[13] nnet_7.3-16 labelled_2.9.1 kableExtra_1.3.4
[16] plotly_4.10.0 gridExtra_2.3 ggplot2_3.3.6
[19] DT_0.23 tableone_0.13.2 magrittr_2.0.3
[22] lubridate_1.8.0 dplyr_1.0.9 plyr_1.8.7
[25] data.table_1.14.2 rmdformats_1.0.4 knitr_1.39
loaded via a namespace (and not attached): [1] insight_0.18.0 webshot_0.5.3 httr_1.4.3 backports_1.4.1
[5] tools_4.2.0 bslib_0.3.1 sjlabelled_1.2.0 utf8_1.2.2
[9] R6_2.5.1 DBI_1.1.2 lazyeval_0.2.2 colorspace_2.0-3 [13] withr_2.5.0 tidyselect_1.1.2 emmeans_1.7.5 compiler_4.2.0
[17] performance_0.9.1 cli_3.3.0 rvest_1.0.2 xml2_1.3.3
[21] sandwich_3.0-2 labeling_0.4.2 bookdown_0.27 bayestestR_0.12.1 [25] sass_0.4.1 mvtnorm_1.1-3 systemfonts_1.0.4 stringr_1.4.0
[29] digest_0.6.29 minqa_1.2.4 rmarkdown_2.14 svglite_2.1.0
[33] pkgconfig_2.0.3 htmltools_0.5.2 fastmap_1.1.0 highr_0.9
[37] htmlwidgets_1.5.4 rlang_1.0.2 rstudioapi_0.13 jquerylib_0.1.4
[41] generics_0.1.2 farver_2.1.0 zoo_1.8-10 jsonlite_1.8.0
[45] crosstalk_1.2.0 parameters_0.18.1 Rcpp_1.0.8.3 munsell_0.5.0
[49] fansi_1.0.3 lifecycle_1.0.1 multcomp_1.4-19 stringi_1.7.6
[53] yaml_2.3.5 MASS_7.3-54 grid_4.2.0 sjmisc_2.8.9
[57] forcats_0.5.1 crayon_1.5.1 lattice_0.20-45 ggeffects_1.1.2
[61] haven_2.5.0 splines_4.2.0 sjstats_0.18.1 hms_1.1.1
[65] pillar_1.7.0 boot_1.3-28 estimability_1.4 effectsize_0.7.0 [69] codetools_0.2-18 glue_1.6.2 evaluate_0.15 mitools_2.4
[73] modelr_0.1.8 vctrs_0.4.1 nloptr_2.0.3 gtable_0.3.0
[77] purrr_0.3.4 tidyr_1.2.0 datawizard_0.4.1 xfun_0.31
[81] broom_0.8.0 xtable_1.8-4 survey_4.1-1 survival_3.2-13
[85] viridisLite_0.4.0 tibble_3.1.7 TH.data_1.1-1 ellipsis_0.3.2